home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
MENU_UTL
/
BMENU
/
BMENUT1.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1990-09-07
|
4KB
|
156 lines
program BMENUT1; { John Haluska, CIS 74000,1106 Turbo Pascal 5.5 }
{ Demo program for BMenu unit which shows how to use the MItem and MMenu
objects to generate Lotus style horizontal and vertical bar menus. }
uses
Crt,BMenu;
type
HeapStat = object {Monitor heap usage}
HeapStart,HeapIncrMax : longint;
procedure Init;
procedure GetHeapUsed;
function HeapNow : longint;
end;
procedure HeapStat.Init;
begin
HeapStart := MemAvail;
HeapIncrMax := 0;
end;
procedure HeapStat.GetHeapUsed;
var
HeapIncr : longint;
begin
HeapIncr := HeapStart - MemAvail;
if HeapIncrMax < HeapIncr then HeapIncrMax := HeapIncr
end;
function HeapStat.HeapNow : longint;
begin
HeapNow := MemAvail;
end;
var
OldTextAttr : byte;
Hs : HeapStat;
procedure SubMenuA;
var
Ms : MMenuPtr;
Ch : char;
begin
Ch := '2';
New(Ms,Init('1234Q',Red*16 + LightGray));
Ms^.Append(New(MItemPtr,Init(5,9, ' 1 Item ')));
Ms^.Append(New(MItemPtr,Init(5,10,' 2 Item ')));
Ms^.Append(New(MItemPtr,Init(5,11,' 3 Item ')));
Ms^.Append(New(MItemPtr,Init(5,12,' 4 Item ')));
Ms^.Append(New(MItemPtr,Init(5,13,' Quit ')));
Hs.GetHeapUsed;
repeat
Ch := Ms^.MenuPick(Ch);
TextAttr := OldTextAttr;
GoToXY(2,20);
if (Ch = 'Q') or (Ch = #27) then
Write(' ':70)
else
Write('Char ',Ch,' returned. Select "Quit" or Esc to exit.',' ':25);
until (Ch = 'Q') or (Ch = #27);
TextAttr := OldTextAttr;
Dispose(Ms,EraseMenu);
end;
procedure SubMenuB;
var
Ms : MMenuPtr;
Ch : char;
begin
Ch := 'G';
New(Ms,Init('AOGP',LightGray*16 + Green));
Ms^.Append(New(MItemPtr,Init(15,9,' Apples ')));
Ms^.Append(New(MItemPtr,Init(15,9,' Oranges ')));
Ms^.Append(New(MItemPtr,Init(15,9,' Grapes ')));
Ms^.Append(New(MItemPtr,Init(15,9,' Peaches ')));
Hs.GetHeapUsed;
repeat
Ch := Ms^.MenuPick(Ch);
TextAttr := OldTextAttr;
GoToXY(2,20);
if Ch = #27 then
Write(' ':70)
else
Write('Char ',Ch,' returned. Esc to exit.',' ':45);
until Ch = #27;
TextAttr := OldTextAttr;
Dispose(Ms,EraseMenu);
end;
procedure SubMenuC;
var
Ms : MMenuPtr;
Ch : char;
begin
Ch := '2';
New(Ms,Init('TDHQ',Black*16 + Green));
Ms^.Append(New(MItemPtr,Init(25,9, ' Tom ')));
Ms^.Append(New(MItemPtr,Init(35,9,' Dick ')));
Ms^.Append(New(MItemPtr,Init(25,11,' Harry ')));
Ms^.Append(New(MItemPtr,Init(35,11,' Quit ')));
Hs.GetHeapUsed;
repeat
Ch := Ms^.MenuPick(Ch);
TextAttr := OldTextAttr;
GoToXY(2,20);
if (Ch = #27) or (Ch = 'Q') then
Write(' ':70)
else
Write('Char ',Ch,' returned. Select Quit or Esc to exit.',' ':45);
until (Ch = #27) or (Ch = 'Q');
TextAttr := OldTextAttr;
Dispose(Ms,EraseMenu);
end;
procedure MainMenu;
var
Mm : MMenuPtr;
Ch : char;
begin
Ch := 'B';
New(Mm,Init('ABCQ',Blue*16 + LightGray));
Mm^.Append(New(MItemPtr,Init(5,5, ' A Item ')));
Mm^.Append(New(MItemPtr,Init(15,5,' B Item ')));
Mm^.Append(New(MItemPtr,Init(25,5,' C Item ')));
Mm^.Append(New(MItemPtr,Init(35,5,' Quit ')));
Hs.GetHeapUsed;
repeat
Ch := Mm^.MenuPick(Ch); {Initial select is previous select}
TextAttr := OldTextAttr;
GoToXY(2,20);
Write('Char ',Ch,' returned.',' ':60);
case Ch of
'A' : SubMenuA;
'B' : SubMenuB;
'C' : SubMenuC;
'Q' : ;
end;
until (Ch = 'Q') or (Ch = #27);
Dispose(Mm,Done); { Deallocate heap memory }
end;
begin
ClrScr;
Hs.Init;
Writeln(#13,#10,' Bar menu demo. Cursor/Enter keys or 1st letter ',
'selects the menu item. ',#13,#10,
' Esc cancels selection and exits menu.');
OldTextAttr := TextAttr;
MainMenu;
GoToXY(2,20);
Write('Heap Bytes Before: ',Hs.HeapStart,' After: ',Hs.HeapNow,
' Max Used: ',Hs.HeapIncrMax,' ':20);
TextAttr := OldTextAttr;
end.